home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / support.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  7.7 KB  |  242 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: support.scm,v 1.22 1992/09/20 17:43:11 birkholz Exp $
  39.  
  40. ;;;; General Supporting Procedures
  41.  
  42. ;;; This file contains general support routines used at runtime by Dylan
  43. ;;; procedures.  See also the files generic.scm (generic operator
  44. ;;; dispatch), class.scm (class heterarchy), and runtime.scm
  45. ;;; (Dylan-callable operations written in Scheme).
  46.  
  47. (define the-unassigned-value '<<THE-UNASSIGNED-VALUE>>)
  48. (define *the-uninitialized-slot-value* (list '<<UNINITIALIZED>>))
  49. (define next-method:not-generic #T)    ; Passed as default
  50.                     ; next-method parameter when
  51.                     ; not going through generic
  52.                     ; dispatch mechanism
  53.  
  54. ;; Create a new symbol from two strings (prefix and postfix) and an
  55. ;; existing symbol or string.
  56.  
  57. (define (new-name prefix name postfix)
  58.   (string->symbol
  59.    (canonicalize-string-for-symbol
  60.     (list->string
  61.      (append (string->list prefix)
  62.          (string->list ((if (string? name)
  63.                 canonicalize-string-for-symbol
  64.                 symbol->string)
  65.                 name))
  66.          (string->list postfix))))))
  67.  
  68. ;;;; Slot descriptors
  69.  
  70. (define slot-type
  71.   (make-record-type
  72.    'dylan-slot
  73.    '(debug-name
  74.      getter
  75.      setter
  76.      type
  77.      init-value
  78.      has-init-value?
  79.      init-function
  80.      init-keyword
  81.      required-init-keyword
  82.      allocation
  83.      inherited?
  84.      data-location)))            ; Depends on allocation type:
  85.                     ;  Instance = offset in instance data
  86.                     ;  Class = (class-ptr . offset)
  87.                     ;  Each-Subclass = offset in class-data
  88.                     ;  Virtual = #F
  89.                     ;  Constant = the value of the slot
  90. (define slot? (record-predicate slot-type))
  91. (define make-slot (record-constructor slot-type))
  92. (define slot.debug-name
  93.   (record-accessor slot-type 'debug-name))
  94. (define slot.getter
  95.   (record-accessor slot-type 'getter))
  96. (define slot.setter
  97.   (record-accessor slot-type 'setter))
  98. (define slot.type
  99.   (record-accessor slot-type 'type))
  100. (define slot.init-value
  101.   (record-accessor slot-type 'init-value))
  102. (define slot.has-initial-value?
  103.   (record-accessor slot-type 'has-init-value?))
  104. (define slot.init-function
  105.   (record-accessor slot-type 'init-function))
  106. (define slot.init-keyword
  107.   (record-accessor slot-type 'init-keyword))
  108. (define slot.required-init-keyword
  109.   (record-accessor slot-type 'required-init-keyword))
  110. (define slot.allocation
  111.   (record-accessor slot-type 'allocation))
  112. (define slot.inherited?
  113.   (record-accessor slot-type 'inherited?))
  114. (define slot.data-location
  115.   (record-accessor slot-type 'data-location))
  116. (define set-slot.debug-name!
  117.   (record-updater slot-type 'debug-name))
  118. (define set-slot.getter!
  119.   (record-updater slot-type 'getter))
  120. (define set-slot.setter!
  121.   (record-updater slot-type 'setter))
  122. (define set-slot.type!
  123.   (record-updater slot-type 'type))
  124. (define set-slot.init-value!
  125.   (record-updater slot-type 'init-value))
  126. (define set-slot.has-initial-value?!
  127.   (record-updater slot-type 'has-init-value?))
  128. (define set-slot.init-function!
  129.   (record-updater slot-type 'init-function))
  130. (define set-slot.init-keyword!
  131.   (record-updater slot-type 'init-keyword))
  132. (define set-slot.required-init-keyword!
  133.   (record-updater slot-type 'required-init-keyword))
  134. (define set-slot.allocation!
  135.   (record-updater slot-type 'allocation))
  136. (define set-slot.inherited?!
  137.   (record-updater slot-type 'inherited?))
  138. (define set-slot.data-location!
  139.   (record-updater slot-type 'data-location))
  140.  
  141. ;;;; Keywords and names
  142.  
  143. (define (keyword? obj)
  144.   (and (symbol? obj)
  145.        (let ((string (symbol->string obj)))
  146.      (char=? #\: (string-ref string
  147.                  (- (string-length string) 1))))))
  148.  
  149. (define (dylan::find-keyword keyword-list keyword default-fn)
  150.   (let loop ((rest keyword-list))
  151.     (cond ((null? rest) (default-fn))
  152.       ((eq? keyword (car rest)) (cadr rest))
  153.       (else (loop (cddr rest))))))
  154.  
  155. (define (validate-keywords arglist allowed error)
  156.   (let loop ((args arglist))
  157.     (cond ((null? args) #T)
  158.       ((or (not (pair? args))
  159.            (not (pair? (cdr args)))
  160.            (not (keyword? (car args))))
  161.        (error "incorrect keyword format" arglist allowed))
  162.       ((not (or (eq? allowed #T)
  163.             (memq (car args) allowed)))
  164.        (error "illegal keyword argument" (car args)
  165.           (if (eq? allowed #T) 'ANY allowed)))
  166.       (else (loop (cddr args))))))
  167.  
  168. ;;;; General utilities
  169.  
  170. (define (last l)
  171.   (if (null? l)
  172.       '()
  173.       (let loop ((l l))
  174.     (if (null? (cdr l))
  175.         (car l)
  176.         (loop (cdr l))))))
  177.  
  178. (define (split-last l continue)
  179.   (if (null? l)
  180.       (continue '() '())
  181.       (let loop ((previous '())
  182.          (left l))
  183.     (if (null? (cdr left))
  184.         (continue (reverse previous) left)
  185.         (loop (cons (car left) previous) (cdr left))))))
  186.  
  187. (define (subset? smaller larger)
  188.   (let loop
  189.       ((smaller smaller))
  190.     (if (pair? smaller)
  191.     (if (memq (car smaller) larger)
  192.         (loop (cdr smaller))
  193.         #F)
  194.     #T)))
  195.  
  196. (define (unique? objects predicate)
  197.   (let loop ((objects objects))
  198.     (or (null? objects)
  199.     (and (not (predicate (car objects) (cdr objects)))
  200.          (loop (cdr objects))))))
  201.  
  202. (define (set-difference main subtract predicate)
  203.   (let loop ((result '())
  204.          (to-do main))
  205.     (cond ((null? to-do) (reverse result))
  206.       ((predicate (car to-do) subtract)
  207.        (loop result (cdr to-do)))
  208.       (else (loop (cons (car to-do) result) (cdr to-do))))))
  209.  
  210. (define (union set1 set2 predicate)
  211.   (let loop ((result set1)
  212.          (remaining set2))
  213.     (if (null? remaining)
  214.     result
  215.     (loop (if (predicate (car remaining) result)
  216.           result
  217.           (cons (car remaining) result))
  218.           (cdr remaining)))))
  219.  
  220. (define (adjoin elem set predicate)
  221.   (if (predicate elem set)
  222.       set
  223.       (cons elem set)))
  224.  
  225. (define (any? fn l)
  226.   (and (not (null? l))
  227.        (or (fn (car l))
  228.        (any? fn (cdr l)))))
  229.  
  230. (define (all? fn l)
  231.   (or (null? l)
  232.       (and (fn (car l))
  233.        (all? fn (cdr l)))))
  234.  
  235. (define (but-first count list)
  236.   (if (= count 0)
  237.       list
  238.       (but-first (- count 1) (cdr list))))
  239.  
  240. (define (population->list population)
  241.   (map-over-population population (lambda (x) x)))
  242.